home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 18 / fpc103.zip / SAVESYS.SEQ < prev    next >
Text File  |  1988-06-24  |  2KB  |  53 lines
  1. \ SAVESYS.SEQ   SAVE-SYSTEM and                         by Tom Zimmer
  2.  
  3. comment:
  4.  
  5.   This file allows saving the Forth memory image as a .COM file. This
  6. .COM file can include the Forth HEADs, or they may optionally be omitted.
  7. The word SAVE-SYSTEM will save Forth with HEADs.
  8.  
  9. comment;
  10.  
  11. decimal
  12.  
  13. ONLY FORTH ALSO DEFINITIONS
  14.  
  15. : SAVE          ( Addr len {filename} --- )
  16.                 SHNDL+ !HCB
  17.                 SHNDL+ HDELETE   DROP
  18.                 SHNDL+ HCREATE   ABORT" Save Create ERR!"
  19.                 SHNDL+ HWRITE 0= ABORT" Save Write  ERR!"
  20.                 SHNDL+ HCLOSE    ABORT" Save Close  ERR!" ;
  21.  
  22. : XLENGTH       ( --- D1 )
  23.                 XHERE PARAGRAPH + XSEG @ - 16 *D ;
  24.  
  25. variable withheads      withheads on
  26.  
  27. : <SAVE-SYSTEM> ( {filename} -- )
  28.                 XHERE PARAGRAPH + XDPSEG !
  29.                 HERE 0 XLENGTH D+ YHERE 0 D+ 20. D+ SP@ 0 D>
  30.                 ABORT" Too big. Use SAVE-EXE"
  31.                 HERE DPSTART ! XSEG @ 0 ?CS: HERE XLENGTH DROP DUP ALLOT CMOVEL
  32.                 withheads @
  33.                 if      HERE YSTART  !
  34.                         YSEG @ 0 ?CS: HERE YHERE        DUP ALLOT CMOVEL
  35.                 then
  36.                 XMOVED OFF
  37.                 XHERE PARAGRAPH + XSEG @ - XSEGLEN !
  38.                 256 HERE SAVE
  39.                 DPSTART @ DP !
  40.                 YSTART OFF
  41.                 XMOVED ON ;
  42.  
  43. : save-system   ( {filename} --- )
  44.                 withheads on
  45.                 <save-system> ;
  46.  
  47. : turnkey       ( {filename} --- )
  48.                 xhere drop xseg @ - 10 + =: #listsegs
  49.                 0 =: #headsegs
  50.                 withheads off
  51.                 <save-system> ;
  52.  
  53.